home *** CD-ROM | disk | FTP | other *** search
/ PD ROM 1 / PD ROM Volume I - Macintosh Software from BMUG (1988).iso / Programming / FORTH Folder / ARRAY next >
Encoding:
Text File  |  1986-08-08  |  11.6 KB  |  396 lines  |  [TEXT/ttxt]
  1. ( I thought that Michael Ham's column in the July issue
  2.     of DDJ was so neat that I translated it into Mach 1
  3.     Macintosh FORTH.  These words behave very much like Ham's.
  4.     In some cases the implementation is very different. )
  5.     
  6. ( Tiny tools )
  7. ( These work just as presented by Ham )
  8. : NIP  ( n m - m )     SWAP DROP ;  ( drops second on stack  )
  9. : TUCK ( n m - m n m ) SWAP OVER ;  ( tucks top under second )
  10. : -ROT ( a b c - c a b ) ROT ROT ;  ( opposite of ROT )     
  11.  
  12. : INCR ( a - )  1 SWAP +! ;   ( increments a variable )
  13. : DECR ( a - ) -1 SWAP +! ;   ( decrements a varaible )
  14.  
  15.   ( ERRCNT INCR increments the variable ERRCNT )
  16.   ( #LINES DECR decrements the variable #LINES ) 
  17.  
  18. : ON  ( a - )  -1 SWAP ! ;  ( forces variable to true value )
  19. : OFF ( a - )   0 SWAP ! ;  ( forces variable to false value )
  20.  
  21. ( NUF? is just like Ham's NUF? except that I use the ` key
  22.     for an escape key )
  23.     
  24. 96 CONSTANT ESC
  25.  
  26. : NUF? ( - f ) ?TERMINAL DUP IF KEY 2DROP KEY ESC = THEN ;
  27.  
  28. ( ESC-HIT? works just like NUF? with the above substitution for the escape
  29.     key )
  30.  
  31. 0 CONSTANT FALSE     
  32. -1 CONSTANT TRUE
  33. 32 CONSTANT BL
  34.  
  35. : ESC-HIT? ( - f ) ( leaves TRUE if Escape key pressed )
  36.    FALSE ?TERMINAL IF BEGIN KEY ESC = OR ?TERMINAL NOT UNTIL THEN ;
  37.  
  38. ALSO ASSEMBLER
  39. CODE WORD-SWAP   ( x -- x' )
  40.     MOVE.L    (A6),D0
  41.     SWAP.W    D0
  42.     MOVE.L    D0,(A6)
  43.     RTS
  44. END-CODE
  45. MACH
  46.  
  47. ( WORD-SWAP is not nearly as clever as Bill Muench's BYTE-SWAP
  48.     for 16 bit FORTHs )
  49.     
  50. ( This 32 bit version of BYTE-SWAP swaps the bytes
  51.     in the least significant word using brute force. )
  52.     
  53. CODE BYTE-SWAP       ( x -- x' )
  54.     MOVE.L    (A6),D0
  55.     MOVE.L    D0,D1
  56.     LSL.W        #8,D0
  57.     LSR.W        #8,D1
  58.     MOVE.B    D1,D0
  59.     MOVE.L    D0,(A6)
  60.     RTS
  61. END-CODE
  62.  
  63. ( Array defining words )
  64.  
  65. (    There are two kinds of of arrays in Mach 1.  Arrays which are
  66.     initialized at compile time and used for permanent data storage;
  67.     i.e. sine tables, should be defined in the dictionary where they
  68.     will be saved to disk with the program. Read-write arrays should be
  69.     defined in the Mac's "below A5" variable space.  Here they don't
  70.     increase code size: they affect only the amount of memory that the
  71.     segment loader reserves for the application at launch.  I give words
  72.     for both kinds of arrays.  The ARE versions of Ham's FOR words
  73.     define the array in variable space. )
  74.     
  75. (    WARNING!   VARIABLE is a smart word in Mach 1.  It checks that each
  76.     variable is alligned on a word boundry, and generates words which
  77.     resolve their addressing modes at compile time for speed.  If you
  78.     FORGET a word defined with VARIABLE the memory it occupied is
  79.     released. The variable space array words given below are pretty dumb.
  80.     If you use them you must EMPTY or reset VP yourself to recover space. )
  81.  
  82. (    WARNING!   Variable space array defining words clobber TMON's
  83.     monitor in high memory.  Install it in the heap.  These words
  84.     seem to work with Apple's RAM cache. )
  85.     
  86. (    Palo Alto Shipping Co. tech support says that VARIABLE will be
  87.     redefined in the August release of Mach 1 to produce Mached words.
  88.     I'll upload smarter versions of the variable space array words
  89.     after I get the new version )
  90.     
  91. ( The next word is useful for all the variable space arrays )
  92.  
  93. CODE   @A5                    ( Returns the address indexed by A5 )
  94.     MOVE.L    A5,-(A6)
  95.     RTS
  96. END-CODE
  97. MACH
  98.  
  99. ( Ham's dictionary version with 32 bit cells )
  100. : ARRAY  CREATE ( # - ) 4 * ALLOT   ( reserves # cells in the dictionary )
  101.          DOES>  ( n <adr> - adr ) SWAP 4 * + ; ( adr of nth cell )
  102.  
  103. ( This array allocates the number of cells specified, but does )
  104. ( not initialize them to zero. ) 
  105. ( Examples )
  106.   8 ARRAY TOM   ( defines TOM as having 8 cells = 32 bytes )
  107.   125 5 TOM !   ( stores 125 in cell 5 of TOM )
  108.   0 TOM @       ( retrieves the contents of cell 0 of TOM )
  109.  
  110. ( The variable space version )
  111.  
  112. : VARRAY   ( # -- )                ( reserves # cells in variable space )
  113.     CREATE VP @ , 4 * VALLOT ( Stores the offset from (A5) where
  114.                                      the arrray begins and increments VP
  115.                                      for next array. )
  116.     DOES>   ( n <addr>  -- addr )   ( computes the absolute address
  117.                                                  of the array element )
  118.     @ @A5 SWAP + SWAP 4 * + ;
  119.     
  120. (    In adapting Ham's second array defining word I leave
  121.     out the ERASE from the dictionary version since
  122.     presumably no one will want to save an array of
  123.     zeros in their code.   )
  124.  
  125.  
  126. 1 CONSTANT BYTES
  127. 2 CONSTANT SHORTS         ( WORDS was the obvious choice here but it
  128.                             has been used already  )
  129. 4 CONSTANT LONGS 
  130. : (FOR)    { index addr -- }
  131.     addr @ index * addr + 4 + ;
  132.     
  133. : FOR  CREATE ( #slots kind - ) DUP , * ALLOT
  134.        DOES> (FOR) ;
  135.  
  136. ( Examples )
  137. 11 BYTES FOR FRED
  138. 35 SHORTS FOR JOAN
  139. 17 LONGS FOR JOHN
  140.  
  141. ( These arrays will deliver the address of the slot based  )
  142. ( on the type of the entry.  It is the programmer's job to  )
  143. ( use C!, W!, !, C@, W@, and @ as appropriate.  Note that  )
  144. ( FRED's 11 slots are numbered 0 through 10, JOAN's 35 are )
  145. ( numbered 0 through 34, and JOHN's 17 are 0 through 16.   )
  146.  
  147. (    Mach 1 doesn't have an ERASE in the kernal. )
  148. : ERASE   ( addr n -- )   ( Zero fills n bytes starting at addr )
  149.     0 FILL ;
  150.  
  151. ( The variable space version does initialize the array to zero. )
  152.  
  153. : (ARE)   { index <addr> | kind -- addr }
  154.     <addr> 4 + @ -> kind
  155.     @A5 <addr> @ + kind index * + ;
  156. : ARE    { #slots kind | start lenght -- }
  157.     CREATE
  158.     VP @ -> start
  159.     #slots kind * -> lenght
  160.     start ,  kind ,
  161.     lenght 2 MOD
  162.     IF
  163.         lenght 1+ -> lenght    ( Mach 1 adjusts HERE to even boundries. )
  164.     THEN                            ( up in variable space the programmer )
  165.     lenght VALLOT                ( must do it. )
  166.     @A5 start + lenght ERASE
  167.     DOES> (ARE) ;
  168.  
  169. ( Examples )
  170. 11 BYTES ARE FRED
  171. 35 SHORTS ARE JOAN
  172. 17 LONGS ARE JOHN
  173.  
  174.  
  175. ( Dictionary version of Ham's array defining word 3 )
  176. ( Typically the index is 6 for vectored execution
  177.     in subroutine threaded FORTH; 4 for the JSR <address>
  178.     generated  by the compiler and 2 for the RTS.
  179.     Here, however, all the fetch and store words are macros.
  180.     I padded C! and W! with no-ops so that I could use and index
  181.     of 10. )
  182.  
  183. TRUE CONSTANT PUT   ( flags for the IF statement )
  184. FALSE CONSTANT FETCH    ( in (FOR) )
  185.  
  186. HEX
  187. : RTS   4E75 W, ; IMMEDIATE
  188. : NOP   4E71 W, ; IMMEDIATE    ( Any two bytes will work here )
  189. DECIMAL
  190.  
  191. CREATE STORES   ] C! RTS NOP W! RTS NOP NOP NOP NOP NOP NOP ! RTS [
  192. CREATE FETCHES  ] C@ RTS W@ RTS NOP NOP NOP NOP NOP @ RTS [
  193.  
  194. : (FOR)   { flag index addr | kind } ( if PUT: datum TRUE index addr -- )
  195.                                                  ( if FETCH: FALSE index addr -- datum )
  196.     addr @ -> kind
  197.     kind index * addr + 4 + 
  198.     kind 1- 10 *
  199.     flag IF
  200.                 STORES
  201.             ELSE
  202.                 FETCHES
  203.             THEN + EXECUTE ;
  204.  
  205. ( FOR is defined just as above. )
  206. : FOR  CREATE ( #slots kind - ) DUP , * ALLOT
  207.        DOES> (FOR) ;
  208.          
  209. ( This version of FOR takes care of the fetching and storing  )
  210. ( given the appropriate flag; the programmer does not have to )
  211. ( remember whether it is a byte, word, or long array. )
  212. ( Examples )
  213. 11 BYTES FOR FRED
  214. 35 SHORTS FOR JOAN
  215. 17 LONGS FOR JOHN
  216.  
  217. 213 PUT 3 FRED                ( stores 213 in byte 3 of FRED )
  218. FETCH 31 JOAN                ( retrieves contents of cell 31 of JOAN )
  219. 3142352 PUT 15 JOHN        ( stores 3142352. in slot 15 of JOHN )
  220.  
  221. ( This is the variable space version of the array which does
  222.     its own fetching and storing )
  223.  
  224. : (ARE)   { flag index addr | kind } ( if PUT: datum TRUE index addr -- )
  225.                                                  ( if FETCH: FALSE index addr -- datum )
  226.     addr 4 + @ -> kind
  227.     @A5 addr @ + index kind * +
  228.     kind 1- 10 *
  229.     flag IF
  230.                 STORES
  231.             ELSE
  232.                 FETCHES
  233.             THEN + EXECUTE ;
  234.  
  235. : ARE    { #slots kind | start lenght -- }
  236.     CREATE
  237.     VP @ -> start
  238.     #slots kind * -> lenght
  239.     start ,  kind ,
  240.     lenght 2 MOD
  241.     IF
  242.         lenght 1+ -> lenght    ( Mach 1 adjusts HERE to even boundries. )
  243.     THEN                            ( up in variable space the programmer )
  244.     lenght VALLOT                ( must do it. )
  245.     @A5 start + lenght ERASE
  246.     DOES> (ARE) ;
  247.  
  248. ( Examples)
  249.  
  250. 11 BYTES ARE FRED
  251. 35 SHORTS ARE JOAN
  252. 17 LONGS ARE JOHN
  253.  
  254. 213 PUT 3 FRED                ( stores 213 in byte 3 of FRED )
  255. FETCH 31 JOAN                ( retrieves contents of cell 31 of JOAN )
  256. 3142352 PUT 15 JOHN        ( stores 3142352. in slot 15 of JOHN )
  257.  
  258. ( 68K version of Ham's bit tools. Notice reversed order of BITBYTES )
  259. CREATE BITBYTES  128 C, 64 C, 32 C, 16 C, 8 C, 4 C, 2 C, 1 C,
  260.  
  261. : MASK   ( bit# -- n )        ( Somehow this was missing from the original )
  262.     BITBYTES + C@ ;            ( listing. )
  263.  
  264. : FLAG ( ? - f ) 0= NOT ; ( forces to a Boolean flag: TRUE or FALSE )
  265.  
  266. : AIM  ( # adr - bit# adr' ) SWAP 8 /MOD ROT + ;
  267.  
  268. : +BIT ( # adr - ) AIM SWAP MASK OVER C@  OR SWAP C! ;
  269.  
  270. : -BIT ( # adr - ) AIM SWAP MASK NOT OVER C@ AND SWAP C! ;
  271.  
  272. : @BIT ( # adr - f ) AIM C@ SWAP MASK AND FLAG ;
  273.  
  274. : ~BIT ( # adr - f ) AIM 2DUP @BIT IF -BIT ELSE +BIT THEN ;
  275.  
  276. ( Note: These bit manipulation routines are as fast as the
  277.     corresponding system utilites when the latter are accessed
  278.     through the trap dispatcher. )
  279.  
  280. ( Ham's array defining word 5, memory version.
  281.     I can't conceive of any use for a disk version of this word.
  282.     If one left out the " #slots , " this would behave identically
  283.     to Ham's array defining word 4. )
  284.  
  285. 0 CONSTANT BITS      ( for bit arrays )
  286. : BITS>BYTES ( #bits - #bytes ) 8 /MOD SWAP IF 1+ THEN ;
  287.  
  288. : (ARE)   { flag? index addr | kind } ( if PUT: datum TRUE index addr -- )
  289.                                                  ( if FETCH: FALSE index addr -- datum )
  290.     addr 4 + @ -> kind
  291.     kind IF
  292.     @A5 addr @ + index kind * +
  293.     kind 1- 10 *
  294.         flag?
  295.             IF
  296.                 STORES
  297.             ELSE
  298.                 FETCHES
  299.             THEN + EXECUTE
  300.         ELSE
  301.             flag? IF        ( Must be SET, ZAP or FLIP )
  302.                         ?DUP IF 0< IF index @A5 addr @ + ~BIT
  303.                                         ELSE index @A5 addr @ + +BIT THEN
  304.                                 ELSE index @A5 addr @ + -BIT THEN
  305.                     ELSE index @A5 addr @ + @BIT THEN
  306.             THEN ;
  307. ( This might be clearer to some if the "index @A5 addr @ +"
  308.     were factored before the "flag?".  Execution speed wouldn't change. )
  309.  
  310. : ARE    { #slots kind | start lenght -- }
  311.     CREATE
  312.     VP @ -> start
  313.     kind IF #slots kind * -> lenght
  314.             ELSE #slots BITS>BYTES -> lenght
  315.             THEN
  316.     start ,  kind , #slots ,   ( lenght needed only for SPILL )
  317.     lenght 2 MOD
  318.     IF
  319.         lenght 1+ -> lenght    ( Mach 1 adjusts HERE to even boundries. )
  320.     THEN                            ( up in variable space the programmer )
  321.     lenght VALLOT                ( must do it. )
  322.     @A5 start + lenght ERASE
  323.     DOES> (ARE) ;
  324.  
  325. : SET   1 TRUE ;
  326. : ZAP   0 TRUE ;
  327. : FLIP   -1 TRUE ;
  328.  
  329. ( Examples )
  330. 23 BITS ARE BIT    ( reserves 4 bytes for bit array )
  331.  
  332. SET 16 BIT    ( turns bit 16 on )
  333. ZAP  5 BIT    ( turns bit 5 off )
  334. FLIP 0 BIT    ( toggles bit 0   )
  335.  
  336. FETCH 3 BIT   ( retrieve bit 3 as boolean flag )
  337.  
  338. "   Bit ByteShort      Long" CONSTANT KINDS
  339.  
  340. : NAME   ( kind slots )
  341.     CR . 5 * KINDS 1+ + 5 TYPE ." s" CR ;
  342.  
  343. : LINE   { end index kind -- }
  344.     end index kind 8 * + MIN index DO I kind 1- 10 * FETCHES + EXECUTE
  345.     7 .R kind +LOOP CR ;
  346.  
  347. : NUMBERS   { start slots kind -- }
  348.     start slots kind * + start DO I . ."  | "
  349.     I' I kind LINE 8 kind * +LOOP ;
  350.  
  351. : FLAGS   { start slots -- }
  352.     start slots BITS>BYTES + start DO I . ."  | "
  353.     8 0 DO I J @BIT IF ."     True" ELSE ."    False" THEN LOOP
  354.     CR LOOP ;
  355.  
  356. : DISPLAY   { addr | start kind slots -- }
  357.     addr @ @A5 + -> start
  358.     addr 4 + @ -> kind
  359.     addr 8 + @ -> slots
  360.     kind slots NAME
  361.     start slots kind ?DUP IF NUMBERS
  362.                                 ELSE    FLAGS
  363.                                 THEN ;
  364.  
  365. (    LINK>CREATURE takes the link field address as returned by FIND
  366.     and jumps over the JSR at the beginning of the found word
  367.     to get to the address of the first comma data. )
  368.  
  369. : LINK>CREATURE   ( lfa -- addr )
  370.     LINK>BODY 4 + ;
  371.  
  372. : SPILL
  373.     BL WORD FIND
  374.     IF LINK>CREATURE DISPLAY
  375.     ELSE DROP ."   No Such Array" CR THEN ;
  376.  
  377. ( Examples )
  378. (
  379. 19 SHORTS ARE BEANS  ok <0>
  380. 45 PUT 3 BREANS  ok <0>
  381. SPILL BEANS 
  382. 19 Shorts
  383. 352652  |       0      0      0     45      0      0      0      0
  384. 352668  |       0      0      0      0      0      0      0      0
  385. 352684  |       0      0      0
  386.  ok <0>
  387. 24 BITS ARE PEAS  ok <0>
  388. FLIP 5 PEAS  ok <0>
  389. SET 9 PEAS  ok <0>
  390. SPILL PEAS 
  391. 24   Bits
  392. 352690  |    False   False   False   False   False    True   False   False
  393. 352691  |    False    True   False   False   False   False   False   False
  394. 352692  |    False   False   False   False   False   False   False   False
  395.  ok <0>
  396.     )